home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1994 November: Tool Chest / Dev.CD Nov 94.toast / Tool Chest / Development Tools & Languages / Macintosh Common Lisp Related / User Contributions / Travers' lisp contrib.sea / Travers' lisp contrib / pixmap-utils.lisp < prev    next >
Encoding:
Text File  |  1992-02-21  |  4.9 KB  |  124 lines  |  [TEXT/CCL2]
  1. (in-package :cl-user)
  2. (require :closstar)
  3. (use-package :clos*)
  4.  
  5. ;;; Pixmap tools
  6.  
  7. ;;; better hook to inspector
  8. ;;; deal with non-zero-based pixmaps, ridiculous sizes, etc.
  9. ;;; deallocate on window close (not for inspect, but as an option for other views)
  10.  
  11. (defclass pm-inspect-window (window) ((pixmap :initarg :pixmap)))
  12.  
  13. (defmethod view-draw-contents ((w pm-inspect-window))
  14.   (with-slots (wptr pixmap) w
  15.     (with-port wptr
  16.       (ccl:with-pointers ((source pixmap)
  17.                           (dest (ccl:rref wptr window.portbits)))
  18.         (let ((bounds (rref source pixmap.bounds :storage :pointer)))
  19.           (#_CopyBits source dest
  20.            bounds bounds 0 (%null-ptr)))))))
  21.  
  22. (defun inspect-pm (pm)
  23.   (let* ((w (rref pm pixmap.bounds.right))
  24.          (h (rref pm pixmap.bounds.bottom)))
  25.     (make-instance 'pm-inspect-window
  26.       :pixmap pm :view-size (make-point w h) :window-title (princ-to-string pm))))
  27.  
  28. (defclass* pixmap-dialog-item (dialog-item)
  29.   (pixmap
  30.    (dispose nil))                       ; GWorld, or T to dispose of pixmap, or NIL
  31.   :initable-instance-variables)
  32.  
  33. (defmethod* initialize-instance :after ((pmdi pixmap-dialog-item) &rest ignore)
  34.   (when pixmap
  35.     (set-view-size pmdi (make-point (rref pixmap pixmap.bounds.right)
  36.                                     (rref pixmap pixmap.bounds.bottom)))))
  37.  
  38. (defmethod* view-default-size ((pmdi pixmap-dialog-item))
  39.   (when pixmap
  40.     (make-point (rref pixmap pixmap.bounds.right)
  41.                 (rref pixmap pixmap.bounds.bottom))))
  42.  
  43. (defmethod* view-draw-contents ((pmdi pixmap-dialog-item))
  44.   (with-port wptr
  45.     (ccl:with-pointers ((source pixmap)
  46.                         (dest (ccl:rref wptr window.portbits)))
  47.       (let ((source-rect (rref source pixmap.bounds :storage :pointer))
  48.             (x (point-h view-position))
  49.             (y (point-v view-position)))
  50.         (rlet ((dest-rect rect
  51.                           :top y :left x
  52.                           :bottom (+ y (point-v view-size))
  53.                           :right (+ x (point-h view-size))))
  54.           (#_CopyBits source dest
  55.            source-rect 
  56.            dest-rect
  57.            0 (ccl::%null-ptr)))))))
  58.  
  59. ;;; This presumes the pixmap is a screen buffer, and isn't in use somewhere else.
  60. (defmethod* remove-view-from-window ((pmdi pixmap-dialog-item))
  61.   (cond ((eq dispose t) 
  62.          (#_disposescreenbuffer pixmap))        ; will this work on other pixmaps?  Who knows?
  63.         (dispose                        ; non-nil non-t means it's a gworld
  64.          (#_DisposeGWorld dispose)))
  65.   (call-next-method))
  66.  
  67. ;;; Body should consist of low-level Quickdraw calls, which will be performed on the generated bitmap.
  68. ;;; Bugs:  doesn't deallocate gworld (because doing so flushes the pixmap as well)
  69. ;;; Temporary fix: return gworld as second value so higher level can dispose of it someday.
  70. (defmacro make-pixmap ((w h) &body body)
  71.   `(rlet ((cgrafptr :pointer) (gdhandle :pointer))
  72.      (#_GetGWorld cgrafptr gdhandle)
  73.      (let* ((gworld (make-gworld ,w ,h))
  74.             (pixmap (#_GetGWorldPixMap gworld)))
  75.        (unwind-protect
  76.          (progn
  77.            (#_SetGworld gworld (ccl:%null-ptr))
  78.            (#_LockPixels pixmap)
  79.            (#_EraseRect (ccl:rref gworld cgrafport.portrect))
  80.            ,@body))
  81.        (#_UnLockPixels pixmap)
  82.        (#_SetGWorld (ccl:%get-ptr cgrafptr) (ccl:%get-ptr gdhandle))
  83.        (values pixmap gworld))))
  84.  
  85. (defun make-gworld (w h)
  86.   (rlet ((bounds-rect :rect :top 0 :left 0 :right w :bottom h)
  87.          (gworldp :pointer))
  88.      (unless (zerop (#_NewGWorld gworldp 0 bounds-rect (ccl:%null-ptr) (ccl:%null-ptr) 0))
  89.        (error "Failed to make gworld"))
  90.      (ccl:%get-ptr gworldp)))
  91.  
  92. (require :pict-scrap)
  93.  
  94. (defmethod picture-to-window  
  95.   ((self window) picture &optional left top right bottom)
  96.   (when picture
  97.     (with-focused-view self
  98.       (with-port (wptr self)
  99.         (cond ((null left)
  100.                (with-pointers ((pict-point picture))
  101.                  (#_DrawPicture picture (rref pict-point picture.picframe :storage :pointer))))
  102.               ((rlet ((r :rect :left left :top top :right right :bottom bottom))
  103.                  (#_DrawPicture picture r))))))))
  104.  
  105. (defun window-snapshot (window &optional box (scale 1) frame)
  106.   (let* ((wptr (slot-value window 'wptr))
  107.          (source-rect (or box (rref wptr window.portrect)))
  108.          (w-width (- (rref source-rect rect.right)
  109.                      (rref source-rect rect.left)))
  110.          (w-height (- (rref source-rect rect.bottom)
  111.                       (rref source-rect rect.top))))
  112.     (make-pixmap ((round (* w-width scale))
  113.                   (round (* w-height scale)))
  114.       (with-pointers ((source (rref wptr window.portbits))
  115.                       (dest (rref (ccl::%getport) window.portbits)))                 
  116.        (#_CopyBits source
  117.                   dest
  118.                   source-rect
  119.                   (rref (ccl::%getport) window.portrect)
  120.                   0 (%null-ptr))
  121.        (when frame
  122.          (#_FrameRect (rref (ccl::%getport) window.portrect)))))))
  123.  
  124.